home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / ibcl-low.lsp < prev    next >
Text File  |  1992-07-09  |  11KB  |  333 lines
  1. ;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; The version of low for Kyoto Common Lisp (KCL)
  28. (in-package 'pcl)
  29.  
  30. ;;;
  31. ;;; The reason these are here is because the KCL compiler does not allow
  32. ;;; LET to return FIXNUM values as values of (c) type int, hence the use
  33. ;;; of LOCALLY (which expands into (LET () (DECLARE ...) ...)) forces
  34. ;;; conversion of ints to objects.
  35. ;;; 
  36. (defmacro %logand (&rest args)
  37.   (reduce-variadic-to-binary 'logand args 0 t 'fixnum))
  38.  
  39. ;(defmacro %logxor (&rest args)
  40. ;  (reduce-variadic-to-binary 'logxor args 0 t 'fixnum))
  41.  
  42. (defmacro %+ (&rest args)
  43.   (reduce-variadic-to-binary '+ args 0 t 'fixnum))
  44.  
  45. ;(defmacro %- (x y)
  46. ;  `(the fixnum (- (the fixnum ,x) (the fixnum ,y))))
  47.  
  48. (defmacro %* (&rest args)
  49.   (reduce-variadic-to-binary '* args 1 t 'fixnum))
  50.  
  51. (defmacro %/ (x y)
  52.   `(the fixnum (/ (the fixnum ,x) (the fixnum ,y))))
  53.  
  54. (defmacro %1+ (x)
  55.   `(the fixnum (1+ (the fixnum ,x))))
  56.  
  57. (defmacro %1- (x)
  58.   `(the fixnum (1- (the fixnum ,x))))
  59.  
  60. (defmacro %svref (vector index)
  61.   `(svref (the simple-vector ,vector) (the fixnum ,index)))
  62.  
  63. (defsetf %svref (vector index) (new-value)
  64.   `(setf (svref (the simple-vector ,vector) (the fixnum ,index))
  65.          ,new-value))
  66.  
  67.  
  68. ;;;
  69. ;;; std-instance-p
  70. ;;;
  71. (si:define-compiler-macro std-instance-p (x)
  72.   (once-only (x)
  73.     `(and (si:structurep ,x)
  74.       (eq (si:structure-name ,x) 'std-instance))))
  75.  
  76. (import 'si:structurep)
  77.  
  78. (defmacro structure-type (x)
  79.   `(si:structure-name ,x))
  80.  
  81. (dolist (inline '((si:structurep
  82.             ((t) compiler::boolean nil nil "type_of(#0)==t_structure")
  83.             compiler::inline-always)
  84.           (si:structure-name
  85.             ((t) t nil nil "(#0)->str.str_name")
  86.             compiler::inline-unsafe)))
  87.   (setf (get (first inline) (third inline)) (list (second inline))))
  88.  
  89. (setf (get 'cclosure-env 'compiler::inline-always)
  90.       (list '((t) t nil nil "(#0)->cc.cc_env")))
  91.  
  92. ;;;
  93. ;;; turbo-closure patch.  See the file kcl-mods.text for details.
  94. ;;;
  95. #+:turbo-closure
  96. (progn
  97. (CLines
  98.   "object tc_cc_env_nthcdr (n,tc)"
  99.   "object n,tc;                        "
  100.   "{return (type_of(tc)==t_cclosure&&  "
  101.   "         tc->cc.cc_turbo!=NULL&&    "
  102.   "         type_of(n)==t_fixnum)?     "
  103.   "         tc->cc.cc_turbo[fix(n)]:   " ; assume that n is in bounds
  104.   "         Cnil;                      "
  105.   "}                                   "
  106.   )
  107.  
  108. (defentry tc-cclosure-env-nthcdr (object object) (object tc_cc_env_nthcdr))
  109.  
  110. (setf (get 'tc-cclosure-env-nthcdr 'compiler::inline-unsafe)
  111.       '(((fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]")))
  112. )
  113.  
  114.  
  115. ;;;; low level stuff to hack compiled functions and compiled closures.
  116. ;;;
  117. ;;; The primary client for this is fsc-low, but since we make some use of
  118. ;;; it here (e.g. to implement set-function-name-1) it all appears here.
  119. ;;;
  120.  
  121. (eval-when (compile eval)
  122.  
  123. (defmacro define-cstruct-accessor (accessor structure-type field value-type
  124.                         field-type tag-name)
  125.   (let ((setf (intern (concatenate 'string "SET-" (string accessor))))
  126.     (caccessor (format nil "pcl_get_~A_~A" structure-type field))
  127.     (csetf     (format nil "pcl_set_~A_~A" structure-type field))
  128.     (vtype (intern (string-upcase value-type))))
  129.     `(progn
  130.        (CLines ,(format nil "~A ~A(~A)                ~%~
  131.                              object ~A;               ~%~
  132.                              { return ((~A) ~A->~A.~A); }       ~%~
  133.                                                       ~%~
  134.                              ~A ~A(~A, new)           ~%~
  135.                              object ~A;               ~%~
  136.                              ~A new;                  ~%~
  137.                              { return ((~A)(~A->~A.~A = ~Anew)); } ~%~
  138.                             "
  139.             value-type caccessor structure-type 
  140.             structure-type
  141.             value-type structure-type tag-name field
  142.             value-type csetf structure-type
  143.             structure-type 
  144.             value-type 
  145.             value-type structure-type tag-name field field-type
  146.             ))
  147.  
  148.        (defentry ,accessor (object) (,vtype ,caccessor))
  149.        (defentry ,setf (object ,vtype) (,vtype ,csetf))
  150.  
  151.  
  152.        (defsetf ,accessor ,setf)
  153.  
  154.        )))
  155. )
  156. ;;; 
  157. ;;; struct cfun {                   /*  compiled function header  */
  158. ;;;         short   t, m;
  159. ;;;         object  cf_name;        /*  compiled function name  */
  160. ;;;         int     (*cf_self)();   /*  entry address  */
  161. ;;;         object  cf_data;        /*  data the function uses  */
  162. ;;;                                 /*  for GBC  */
  163. ;;;         char    *cf_start;      /*  start address of the code  */
  164. ;;;         int     cf_size;        /*  code size  */
  165. ;;; };
  166. ;;; add field-type tag-name
  167. (define-cstruct-accessor cfun-name  "cfun" "cf_name"  "object" "(object)" "cf")
  168. (define-cstruct-accessor cfun-self  "cfun" "cf_self"  "int" "(int (*)())" 
  169.                          "cf")
  170. (define-cstruct-accessor cfun-data  "cfun" "cf_data"  "object" "(object)" "cf")
  171. (define-cstruct-accessor cfun-start "cfun" "cf_start" "int" "(char *)" "cf")
  172. (define-cstruct-accessor cfun-size  "cfun" "cf_size"  "int" "(int)" "cf")
  173.  
  174. (CLines
  175.   "object pcl_cfunp (x)              "
  176.   "object x;                         "
  177.   "{if(x->c.t == (int) t_cfun)       "
  178.   "  return (Ct);                    "
  179.   "  else                            "
  180.   "    return (Cnil);                "
  181.   "  }                               "
  182.   )
  183.  
  184. (defentry cfunp (object) (object pcl_cfunp))
  185.  
  186. ;;; 
  187. ;;; struct cclosure {               /*  compiled closure header  */
  188. ;;;         short   t, m;
  189. ;;;         object  cc_name;        /*  compiled closure name  */
  190. ;;;         int     (*cc_self)();   /*  entry address  */
  191. ;;;         object  cc_env;         /*  environment  */
  192. ;;;         object  cc_data;        /*  data the closure uses  */
  193. ;;;                                 /*  for GBC  */
  194. ;;;         char    *cc_start;      /*  start address of the code  */
  195. ;;;         int     cc_size;        /*  code size  */
  196. ;;; };
  197. ;;; 
  198. (define-cstruct-accessor cclosure-name "cclosure"  "cc_name"  "object"
  199.                          "(object)" "cc")          
  200. (define-cstruct-accessor cclosure-self "cclosure"  "cc_self"  "int" 
  201.                          "(int (*)())" "cc")
  202. (define-cstruct-accessor cclosure-data "cclosure"  "cc_data"  "object"
  203.                           "(object)" "cc")
  204. (define-cstruct-accessor cclosure-start "cclosure" "cc_start" "int" 
  205.                          "(char *)" "cc")
  206. (define-cstruct-accessor cclosure-size "cclosure"  "cc_size"  "int"
  207.              "(int)" "cc")
  208. (define-cstruct-accessor cclosure-env "cclosure"   "cc_env"   "object"
  209.                          "(object)" "cc")
  210.  
  211.  
  212. (CLines
  213.   "object pcl_cclosurep (x)          "
  214.   "object x;                         "
  215.   "{if(x->c.t == (int) t_cclosure)   "
  216.   "  return (Ct);                    "
  217.   "  else                            "
  218.   "   return (Cnil);                 "
  219.   "  }                               "
  220.   )
  221.  
  222. (defentry cclosurep (object) (object pcl_cclosurep))
  223.  
  224.   ;;   
  225. ;;;;;; Load Time Eval
  226.   ;;
  227. ;;; 
  228.  
  229. ;;;